home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / compiler / Match.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  13.2 KB  |  408 lines  |  [TEXT/R*ch]
  1. (* Match.sml : Compile matches to decision trees, then to lambda code
  2.    1996-07-09, 1997-02-03
  3.  
  4.    See P. Sestoft: ML pattern match compilation and partial
  5.    evaluation.  In Danvy, Gl¸ck, and Thiemann (editors): Dagstuhl
  6.    Seminar on Partial Evaluation, February 1996.  Lecture Notes in
  7.    Computer Science 1110, pages 446-464.  Springer-Verlag 1996.
  8.    ftp://ftp.dina.kvl.dk/pub/Staff/Peter.Sestoft/papers/match.ps.gz
  9.  
  10.    Some day the distinction between static and dynamic excons should be
  11.    eradicated from mosml; this would lead to some simplification in
  12.    the match compiler and the back-end.  
  13. *)
  14.  
  15. open Asynt Lambda
  16.  
  17. fun splitPath n obj =
  18.   let fun loop i oargs =
  19.             if i < 0 then oargs else
  20.             loop (i-1) (Lprim(Prim.Pfield i, [obj]) :: oargs)
  21.   in loop (n-1) [] end;
  22.     
  23. val smlExnEi =
  24. { qualid = { qual = "General", id = "Exception" },
  25.   info = ref{ exconArity = 2,
  26.               exconIsGreedy = true,
  27.               exconTag   = SOME Smlexc.exnTagName }
  28. };
  29.  
  30. fun mkPairPat p1 p2 =
  31.   let val loc = Location.xxLR p1 p2 in
  32.     (loc, RECpat(ref (TUPLErp [p1, p2])))
  33.   end;
  34.  
  35. fun mkExnPat (ii : IdInfo) arg =
  36.   let val {qualid, info} = ii
  37.       val {idLoc, withOp, ...} = info
  38.       val ii' = Asyntfn.mkIdInfo (idLoc, qualid) withOp
  39.   in
  40.     #idKind(#info ii') :=
  41.       { qualid= #qualid smlExnEi, info=EXCONik (#info smlExnEi) };
  42.     EXCONSpat(ii', arg)
  43.   end
  44. ;
  45.  
  46. (* To skip type constraints and aliases, and encode dynamic excons *)
  47.  
  48. fun simplifyPat (loc, pat') =
  49.     case pat' of
  50.     VARpat _         => WILDCARDpat
  51.       | REFpat p         => RECpat(ref (TUPLErp [p]))
  52.       | PARpat p         => simplifyPat p
  53.       | TYPEDpat(p,_)    => simplifyPat p
  54.       | LAYEREDpat(_, p) => simplifyPat p
  55.       | EXNILpat ii      =>
  56.     if Types.isExConStatic(Asyntfn.getExConInfo ii) then
  57.         pat'
  58.     else
  59.         let val arg = mkPairPat (loc, EXNAMEpat ii) (loc, WILDCARDpat) 
  60.         in mkExnPat ii arg end
  61.       | EXCONSpat(ii, p) =>
  62.     if Types.isExConStatic(Asyntfn.getExConInfo ii) then
  63.         pat'
  64.     else
  65.         let val arg = mkPairPat (loc, EXNAMEpat ii) p 
  66.         in mkExnPat ii arg end
  67.       | _                => pat';
  68.  
  69. fun getExConTag (ei : Globals.ExConInfo) =
  70.     case #exconTag(!ei) of
  71.     NONE     => Fnlib.fatalError "getExConTag"
  72.       | SOME tag => tag;
  73.  
  74. (* Constructors *)
  75.  
  76. datatype con = 
  77.     SCon of Const.SCon
  78.   | Tup of int                (* arity                *)
  79.   | Vec of int                (* matching tag = arity *)
  80.   | CCon of Const.BlockTag * int    (* arity                *)
  81.   | EExn of Asynt.IdInfo        (* dynamic excon        *)
  82.  
  83. fun span (SCon (Const.CHARscon _))         = 256
  84.   | span (SCon _)                          = 0       (* infinity *)
  85.   | span (Tup _)                           = 1
  86.   | span (Vec _)                           = 0       (* infinity *)
  87.   | span (CCon (Const.CONtag(_, span), _)) = span
  88.   | span (CCon (Const.EXNtag _, _))        = 0       (* infinity *)
  89.   | span (EExn _)                          = 0       (* infinity *)
  90.  
  91. fun arity (SCon _)          = 0
  92.   | arity (Tup arity)       = arity
  93.   | arity (Vec arity)       = arity
  94.   | arity (CCon (_, arity)) = arity
  95.   | arity (EExn _)          = 0
  96.  
  97. (* Term descriptions *)
  98.  
  99. datatype termd =
  100.     Pos of con * termd list                (* All arguments in proper order *)
  101.   | Neg of con list                        (* No duplicates                 *)
  102.  
  103. val Bot = Neg []                           (* The absence of information    *)
  104.  
  105. fun bots n = List.tabulate(n, fn _ => Bot)
  106.  
  107. (* Contexts, or inside-out partial term descriptions:
  108.  * Example: The context [(c2, [a2, a1]), (c1, [b2, b1])] represents
  109.  * a term description with a hole, of the form
  110.  *           c1(b1, b2, c1(a1, a2, Bot, ..., Bot), Bot, ..., Bot) 
  111.  * where the number of Bots is determined by the arity of c1 and c2.
  112.  *) 
  113.  
  114. type context = (con * termd list) list
  115.  
  116. (* Static matching *)
  117.  
  118. datatype matchresult = Yes | No | Maybe
  119.  
  120. fun staticmatch pcon (Pos(scon, _)) = 
  121.     if pcon = scon then Yes 
  122.     else (case pcon of
  123.           EExn _ => Maybe    (* Different excons may have same name *)
  124.         | _      => No)
  125.   | staticmatch pcon (Neg nonset)   =
  126.     if Fnlib.member pcon nonset then 
  127.         No
  128.     else if span pcon = 1 + List.length nonset then 
  129.         Yes
  130.     else 
  131.         Maybe
  132.  
  133. (* Managing partial terms and contexts *)
  134.  
  135. fun addneg (Neg nonset) con = Neg(con :: nonset)
  136.   | addneg dsc            _ = dsc
  137.  
  138. fun apply []                  dsc = []
  139.   | apply ((con, args)::rest) dsc = 
  140.     if arity con = List.length args + 1 then 
  141.         apply rest (Pos(con, List.rev(dsc :: args)))
  142.     else
  143.         (con, dsc :: args) :: rest
  144.  
  145. fun revappend []      res = res
  146.   | revappend (x::xr) res = revappend xr (x::res)
  147.  
  148. fun builddsc []                  dsc []                      = dsc
  149.   | builddsc ((con, args)::rest) dsc ((_, _, sargs) :: work) = 
  150.     builddsc rest (Pos(con, revappend args (dsc :: sargs))) work
  151.   | builddsc _                   _   _ = Fnlib.fatalError "Match.builddsc"
  152.  
  153. (* Runtime data access and matching actions *)
  154.  
  155. type access = Lambda.Lambda
  156.  
  157. datatype dec =
  158.     Failure
  159.   | Success of Lambda            (* right-hand side *)
  160.   | IfEq of access * con * decision * decision
  161. withtype decision = 
  162.     {tree : dec, refs : int ref, lamRef : Lambda option ref} ref
  163.  
  164. fun shared (ref {refs as ref count, ...}   : decision) = count > 1
  165. fun used   (ref {refs as ref count, ...}   : decision) = count > 0
  166. fun incrnode (ref {refs as ref count, ...} : decision) = refs := 1 + count
  167. fun mkDecision t = ref {tree = t, refs = ref 0, lamRef = ref NONE}
  168.  
  169.  
  170. (* Hash-consing, to get a decision dag rather than a decision tree *)
  171.  
  172. val table = Hasht.new 37 : (dec, decision) Hasht.t
  173.  
  174. fun unique (node as IfEq(_, _, t1, t2)) = 
  175.     if t1 = t2 then t1
  176.     else (Hasht.find table node
  177.       handle Subscript => 
  178.           let val rnode = mkDecision node
  179.           in 
  180.           incrnode t1; incrnode t2; 
  181.           Hasht.insert table node rnode;
  182.           rnode
  183.           end)
  184.   | unique _ = Fnlib.fatalError "Match.unique";
  185.  
  186. fun makedag failure ([] : (Asynt.Pat list * decision) list) : decision = 
  187.     Fnlib.fatalError "Match.makedag: no rules"
  188.   | makedag failure (allmrules as (pats1, _) :: _) = 
  189. let 
  190. val noOfPats = List.length pats1
  191. val objs1 = List.rev (List.tabulate(noOfPats, Lvar))
  192.  
  193. val topCon = Tup noOfPats        (* Hack to handle top-level pat list *)
  194. val topctx = [(topCon, [])] : context
  195.  
  196. fun fail _              []                          = failure
  197.   | fail (Pos(_, dscs)) ((pats1, rhs1) :: rulerest) =
  198.     succeed topctx [(pats1, objs1, dscs)] rhs1 rulerest
  199.   | fail _ _ = Fnlib.fatalError "Match.fail"
  200.  
  201. and succeed ctx []                rhs rules = rhs
  202.   | succeed ctx (work1::workrest) rhs rules = 
  203.     case work1 of 
  204.     ([], [], []) => succeed ctx workrest rhs rules
  205.       | (pat1::patrest, obj1::objrest, dsc1::dscrest) =>
  206.         match pat1 obj1 dsc1 ctx 
  207.         ((patrest, objrest, dscrest) :: workrest) rhs rules
  208.       | _ => Fnlib.fatalError "Match.succeed"
  209.  
  210. and mktest pcon obj dsc ctx work rhs rules conequal =
  211.     case staticmatch pcon dsc of
  212.     Yes   => conequal dsc
  213.       | No    => fail (builddsc ctx dsc work) rules
  214.       | Maybe => 
  215.         unique(IfEq(obj, pcon, 
  216.             conequal (Pos(pcon, bots (arity pcon))),
  217.             fail (builddsc ctx (addneg dsc pcon) work) rules))
  218.  
  219. and match pat obj dsc ctx work rhs rules =
  220.     case simplifyPat pat of
  221.     SCONpat (scon, _) => 
  222.         let fun conequal newdsc = 
  223.         succeed (apply ctx newdsc) work rhs rules
  224.         in mktest (SCon scon) obj dsc ctx work rhs rules conequal end
  225.  
  226.       | VECpat pats =>
  227.         let val arity = List.length pats
  228.         val pcon = Vec arity
  229.         fun getsargs (Neg _)           = bots arity
  230.           | getsargs (Pos(con, sargs)) = sargs
  231.         fun conequal newdsc =
  232.             case pats of
  233.             [] => succeed (apply ctx newdsc) work rhs rules
  234.               | _  => succeed ((pcon, []) :: ctx) 
  235.                           ((pats, splitPath arity obj, getsargs dsc) 
  236.                        :: work)
  237.                       rhs rules
  238.         in 
  239.         mktest pcon (Lprim(Prim.Pvectlength, [obj])) dsc ctx work rhs 
  240.                rules conequal
  241.         end
  242.  
  243.       | WILDCARDpat =>
  244.         succeed (apply ctx dsc) work rhs rules
  245.         
  246.       | NILpat ii =>
  247.         let val ci = !(Asyntfn.getConInfo ii)
  248.         val pcon = CCon(Const.CONtag(#conTag ci, #conSpan ci), 0)
  249.         fun conequal newdsc = 
  250.             succeed (apply ctx newdsc) work rhs rules
  251.         in mktest pcon obj dsc ctx work rhs rules conequal end
  252.  
  253.       | CONSpat (ii, pat) =>
  254.         let val ci = !(Asyntfn.getConInfo ii)
  255.         val pcon = CCon(Const.CONtag(#conTag ci, #conSpan ci), 1)
  256.         val oarg = if #conIsGreedy ci orelse #conSpan ci = 1 then obj
  257.                else Lprim(Prim.Pfield 0, [obj])
  258.         fun getsargs (Neg _)           = [ Bot ]
  259.           | getsargs (Pos(con, sargs)) = sargs
  260.         fun conequal newdsc =
  261.             succeed ((pcon, []) :: ctx) 
  262.                     (([pat], [oarg], getsargs dsc) :: work)
  263.                 rhs rules
  264.         in mktest pcon obj dsc ctx work rhs rules conequal end
  265.  
  266.       | EXNILpat ii =>
  267.         let val ei = Asyntfn.getExConInfo ii
  268.         val pcon = CCon(Const.EXNtag (getExConTag ei), 0)
  269.         fun conequal newdsc = 
  270.             succeed (apply ctx newdsc) work rhs rules
  271.         in mktest pcon obj dsc ctx work rhs rules conequal end
  272.  
  273.       | EXCONSpat (ii, pat) =>
  274.         let val ei = Asyntfn.getExConInfo ii
  275.         val pcon = CCon(Const.EXNtag (getExConTag ei), 1)
  276.         val oarg = if #exconIsGreedy (!ei) then obj
  277.                else Lprim(Prim.Pfield 0, [obj])
  278.         fun getsargs (Neg _)           = [ Bot ]
  279.           | getsargs (Pos(con, sargs)) = sargs
  280.         fun conequal newdsc =
  281.             succeed ((pcon, []) :: ctx) 
  282.                     (([pat], [oarg], getsargs dsc) :: work)
  283.                 rhs rules
  284.         in mktest pcon obj dsc ctx work rhs rules conequal end
  285.  
  286.       | EXNAMEpat ii =>
  287.         let fun conequal newdsc = 
  288.             succeed (apply ctx newdsc) work rhs rules
  289.         in mktest (EExn ii) obj dsc ctx work rhs rules conequal end
  290.  
  291.       | RECpat(ref (TUPLErp [])) =>    (* The irrefutable pattern () or {} *)
  292.         succeed (apply ctx dsc) work rhs rules
  293.  
  294.       | RECpat(ref (TUPLErp pats)) =>
  295.         let val arity = List.length pats
  296.         val sargs = case dsc of 
  297.                           Neg _         => bots arity
  298.                 | Pos(_, sargs) => sargs
  299.         in 
  300.         succeed ((Tup arity, []) :: ctx)
  301.                 ((pats, splitPath arity obj, sargs) :: work) 
  302.             rhs rules
  303.         end
  304.  
  305.       | RECpat(ref (RECrp _)) => Fnlib.fatalError "match 1"
  306.       | _                     => Fnlib.fatalError "match 2"
  307. in 
  308.     fail (Pos(topCon, bots noOfPats)) allmrules
  309. end
  310.  
  311. (* Switchify and compile decision nodes to Lambda-code.  Each shared
  312.  * subdag is compiled once, to a Lambda.Lshared.  *)
  313.  
  314. fun tolambda env (ref {tree, ...} : decision) (failLam : Lambda) : Lambda =
  315.     let fun getSCon (SCon scon)      = scon
  316.           | getSCon _                = Fnlib.fatalError "Match.getSCon"
  317.     fun getCCon (CCon (ccon, _)) = ccon
  318.           | getCCon _                = Fnlib.fatalError "Match.getCCon"
  319.     fun getVec (Vec n)           = Const.INTscon n
  320.       | getVec _                 = Fnlib.fatalError "Match.getVec"
  321.  
  322.     fun collect getcon last cases
  323.          (otherwise as 
  324.           ref {tree = IfEq(obj, con, thenact, elseact), ...}) =
  325.         if obj = last andalso not (shared otherwise) then 
  326.         collect getcon last ((getcon con, thenact) :: cases) elseact
  327.         else
  328.         (cases, otherwise) 
  329.       | collect _ _ cases otherwise = 
  330.         (cases, otherwise)
  331.  
  332.     fun revmap f xys = 
  333.         let fun loop []            res = res
  334.           | loop ((x, y)::xyr) res = loop xyr ((x, f y) :: res)
  335.         in loop xys [] end
  336.  
  337.     fun toseq Failure       = failLam
  338.       | toseq (Success rhs) = rhs
  339.       | toseq t = mkSwitch t    
  340.  
  341.     and share (node as ref {tree, lamRef as ref lamOpt, ...}) =
  342.         if shared node then
  343.         case lamOpt of
  344.             NONE     => let val lam = shared_lambda (toseq tree)
  345.                 in lamRef := SOME lam; lam end
  346.           | SOME lam => lam
  347.         else 
  348.         toseq tree
  349.  
  350.     and mkSwitch (IfEq(obj, SCon scon, thenact, elseact)) = 
  351.         let val (cases, otherwise) = collect getSCon obj [] elseact 
  352.         in 
  353.         Lstatichandle(Lcase(obj, (scon, share thenact)
  354.                          :: revmap share cases),
  355.                   share otherwise)
  356.         end
  357.       | mkSwitch (IfEq(obj, con as Vec _, thenact, elseact)) = 
  358.         let val (cases, otherwise) = collect getVec obj [] elseact 
  359.         in 
  360.         Lstatichandle(Lcase(obj, (getVec con, share thenact)
  361.                                          :: revmap share cases),
  362.                   share otherwise)
  363.         end
  364.  
  365.       | mkSwitch (IfEq(obj, con as CCon _, thenact, elseact)) = 
  366.         let val (cases, otherwise) = collect getCCon obj [] elseact 
  367.         in 
  368.         Lstatichandle(Lswitch(span con, obj, 
  369.                       (getCCon con, share thenact)
  370.                       ::revmap share cases),
  371.                   share otherwise)
  372.         end
  373.  
  374.       | mkSwitch (IfEq(obj, EExn ii, thenact, elseact)) = 
  375.         let val exnname = Tr_env.translateExName env ii
  376.         in 
  377.         Lif(Lprim(Prim.Ptest Prim.Peq_test, [obj, exnname]), 
  378.             share thenact, 
  379.             share elseact)
  380.         end
  381.       | mkSwitch tree = toseq tree
  382.  
  383.     in toseq tree end
  384.  
  385. (* The entry point *)
  386.  
  387. fun translateMatch (env : Tr_env.TranslEnv) failure_code loc mrules =
  388.   let val failure = mkDecision Failure
  389.       val uniqmrules = 
  390.       List.map (fn (pats, rhs) => (pats, mkDecision (Success rhs))) mrules
  391.       val decdag = makedag failure uniqmrules 
  392.       val _ = incrnode decdag;
  393.       val _ = Hasht.clear table        (* Discard memo-table *)
  394.       open Mixture
  395.   in
  396.       if List.exists (fn (_, rhs) => not (used rhs)) uniqmrules then
  397.       (msgIBlock 0;
  398.        Location.errLocation loc;
  399.        errPrompt "Warning: some cases are unused in this match.";
  400.        msgEOL(); msgEOL();
  401.        msgEBlock())
  402.       else ();
  403.       if used failure then                       (* Inexhaustive match *)
  404.       tolambda env decdag (failure_code ())
  405.       else
  406.       tolambda env decdag Lunspec
  407.   end
  408.